home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / DB_CLIPP / 3032.ZIP / RLIB20.ZIP / RL_MULTI.PRG < prev    next >
Text File  |  1989-02-18  |  13KB  |  404 lines
  1. * Function: MULTIMENU
  2. * Author..: Richard Low
  3. * Syntax..: MULTIMENU( top, left, bottom, right, options [, columns ;
  4. *                      [, messages [, message_row [, colors ] ] ] ] )
  5. * Returns.: choice = <expN> - number of array element option picked, or
  6. *                             0 (zero) if escape was pressed
  7. * Notes...: If a parameter is not used, must pass a dummy parameter.
  8. * Where...: top      = <expN> - top row number of window
  9. *           left     = <expN> - top left corner of menu box
  10. *           bottom   =
  11. *           right    =
  12. *           options  = <expA> - array of choices
  13. *           columns  = <expN> - Optional number of columns
  14. *           messages = <expA> - Optional array of choice messages
  15. *           mess_row = <expN> - Optional row # to center messages
  16. *           colors   = <expC> - Optional ARRAY of color settings
  17.  
  18. FUNCTION MULTIMENU
  19. PARAMETERS p_top, p_left, p_bottom, p_right, p_opts, p_cols,;
  20.            p_mess, p_messrow, p_colors
  21.  
  22. *-- all parameter variables identified with 'p_'
  23. *-- all local (function) variables identified with 'f_'
  24.  
  25. PRIVATE f_mess_on, f_widest, f_incolor,  f_selected,  f_menubar, f_space,;
  26.         f_filler,  f_choice, f_firstopt, f_lastopt, f_lastrow, f_lastcol,;
  27.         f_row, f_col, f_x
  28.  
  29. *-- verify that all required parameters are the correct type
  30. IF TYPE('p_top')   + TYPE('p_left') + TYPE('p_bottom') +;
  31.    TYPE('p_right') + TYPE('p_opts') != 'NNNNA'
  32.    RETURN 0
  33. ENDIF
  34.  
  35. *-- verify the window coordinates are within bounds and in the correct order
  36. IF .NOT. ( p_top    >= 0     .AND. p_top    < 25 .AND.;
  37.            p_left   >= 0     .AND. p_left   < 80 .AND.;
  38.            p_bottom > p_top  .AND. p_bottom < 25 .AND.;
  39.            p_right  > p_left .AND. p_right  < 80 )
  40.    RETURN 0
  41. ENDIF
  42.  
  43. *-- verify there is at least 1 element in the options array
  44. IF LEN(p_opts) = 0
  45.    RETURN 0
  46. ENDIF
  47.  
  48. *-- messages displayed only if <p_mess> parmameter is an array
  49. f_mess_on = ( TYPE('p_mess') = 'A' )
  50.  
  51. *-- messages displayed on line 24 unles otherwise specified
  52. p_messrow = IF( TYPE('p_messrow') = 'N', p_messrow, 24 )
  53.  
  54.  
  55. *-- get the widest option from the array
  56. f_widest = 1
  57. FOR f_x = 1 TO LEN(p_opts)
  58.    f_widest = MAX( f_widest, LEN(p_opts[f_x]) )
  59. NEXT f_x
  60.  
  61.  
  62. *-- if # columns not specified, or skipped with wrong data type
  63. IF TYPE('p_cols') != 'N'
  64.    p_cols = 0
  65. ENDIF
  66.  
  67. *-- from above or if zero passed
  68. IF p_cols = 0
  69.    *-- use as many columns as can fit with widest option in window
  70.    p_cols = INT( (p_right - p_left + 1) / (f_widest + 1) ) + 1
  71. ENDIF
  72.  
  73.  
  74. *-- make sure the number of columns specified will fit on screen
  75. *-- allowing a minimum of 1 space between each option
  76. DO WHILE ( ( f_widest + 1 ) * p_cols ) > ( p_right - p_left + 1 )
  77.    *-- if not, trim down the number of columns (sorry!)
  78.    p_cols = p_cols - 1
  79. ENDDO
  80.  
  81.  
  82. *-- if the widest option was too wide to fit in the window, bomb out
  83. IF p_cols < 1
  84.    RETURN 0
  85. ENDIF
  86.  
  87.  
  88. *-- set up array to hold column numbers
  89. DECLARE f_column[p_cols]
  90.  
  91. *-- default minimum amount of space between column options is 1 space
  92. f_filler = 1
  93.  
  94. *-- if number of columns is more than 1, (why else would this UDF be used)
  95. *-- calculate column positions based on widest option, # columns, and window
  96. IF p_cols > 1
  97.    *-- amount of space to use for filler between columns
  98.    f_space = (p_right - p_left + 1) - (f_widest * p_cols)
  99.    *-- divvy white space up between the columns
  100.    f_filler = f_space / (p_cols - 1)
  101.    *-- make sure remainders dont screw it all up, trim down filler if needed
  102.    DO WHILE (((f_widest + f_filler) * (p_cols - 1)) + f_widest) > (p_right-p_left+1)
  103.       f_filler = f_filler - 1
  104.    ENDDO
  105.    *-- make sure it results to positive
  106.    f_filler = MAX( f_filler, 1 )
  107. ENDIF
  108.  
  109.  
  110. *-- now fill column array with column numbers, starting at left position
  111. f_column[1] = p_left
  112. FOR f_x = 2 TO p_cols
  113.    f_column[f_x] = f_column[f_x-1] + f_widest + f_filler
  114. NEXT f_x
  115.  
  116. *-- now convert filler number to spaces
  117. f_filler = IF( f_filler > 1, SPACE(f_filler), ' ' )
  118.  
  119.  
  120. *****************************************************************************
  121. **  now we are in business, having checked for most all that can go wrong  **
  122. *****************************************************************************
  123.  
  124.  
  125. *-- save incoming color
  126. STORE SETCOLOR() TO f_incolor
  127.  
  128. *-- use <color array> if it is an array AND it has at least 5 elements
  129. IF IF( TYPE('p_colors') = 'A', IF(LEN(p_colors) >= 5, .T., .F.) , .F. )
  130.    f_display  = p_colors[1]                    && display color
  131.    f_menubar  = p_colors[2]                    && menu bar color
  132.    f_selected = p_colors[5]                    && selected option color
  133. ELSE
  134.    f_display  = SETCOLOR()
  135.    f_selected = BRIGHT()
  136.    f_menubar  = GETPARM(2,f_incolor)
  137. ENDIF
  138.  
  139.  
  140. *-- first time in, start at first array element
  141. f_firstopt = 1
  142.  
  143. *-- store the last column used
  144. f_lastcol = p_cols               && maximum last column is actual last column
  145.  
  146.  
  147. *-- now display the options in the window
  148. DO f_say_opts
  149.  
  150.  
  151. DO WHILE .T.
  152.    SETCOLOR(f_menubar)
  153.    f_choice = f_element(f_row,f_col)
  154.    @ f_row,f_column[f_col] SAY p_opts[f_choice]
  155.    SETCOLOR(f_display)
  156.  
  157.    IF f_mess_on
  158.       @ p_messrow,0
  159.       @ p_messrow,(80-LEN(p_mess[f_choice]))/2 SAY p_mess[f_choice]
  160.    ENDIF
  161.    lkey = INKEY(0)
  162.  
  163.    *-- put current selection back in normal video
  164.    @ f_row,f_column[f_col] SAY p_opts[f_choice]
  165.  
  166.    DO CASE
  167.  
  168.       CASE lkey = 13
  169.          *-- Enter key
  170.          EXIT
  171.  
  172.       CASE lkey = 27
  173.          *-- Escape key
  174.          f_choice = 0
  175.          EXIT
  176.  
  177.       CASE lkey = 24 .OR. lkey = 32
  178.          *-- Down Arrow or Space Bar
  179.  
  180.          DO CASE
  181.             *-- first try same column, one row down
  182.             CASE f_element(f_row+1,f_col) <= f_lastopt
  183.                f_row = f_row + 1
  184.  
  185.             *-- next try top of next column to right
  186.             CASE f_element(p_top,f_col+1) <= f_lastopt
  187.                f_row = p_top
  188.                f_col = f_col + 1
  189.  
  190.             *-- else must be at bottom right corner, so go to beginning
  191.             OTHERWISE
  192.                f_row = p_top
  193.                f_col = 1
  194.  
  195.          ENDCASE
  196.  
  197.  
  198.       CASE lkey = 5
  199.          *-- Up Arrow
  200.  
  201.          DO CASE
  202.             *-- first try going up one row in the current column
  203.             CASE f_element(f_row-1,f_col) <= f_lastopt
  204.                f_row = f_row - 1
  205.  
  206.             *-- next try going to the bottom (last row used) of column to left
  207.             CASE f_element(f_lastrow,f_col-1) <= f_lastopt
  208.                f_row = f_lastrow
  209.                f_col = f_col - 1
  210.  
  211.             *-- after that, try one row up from last row used
  212.             CASE f_element(f_lastrow-1,f_col-1) <= f_lastopt
  213.                f_row = f_lastrow - 1
  214.                f_col = f_col - 1
  215.  
  216.             *-- then must be on first option, so try to go to end
  217.             CASE f_element(f_lastrow,f_lastcol) <= f_lastopt
  218.                f_row = f_lastrow
  219.                f_col = f_lastcol
  220.  
  221.             *-- if that didn't work, row dind't fill to end so go up 1
  222.             OTHERWISE
  223.                f_row = f_lastrow - 1
  224.                f_col = f_lastcol
  225.  
  226.          ENDCASE
  227.  
  228.  
  229.       CASE lkey = 4 .OR. lkey = 32
  230.          *-- Right Arrow or Space Bar
  231.  
  232.          DO CASE
  233.             *-- first try same row, one column over
  234.             CASE f_element(f_row,f_col+1) <= f_lastopt
  235.                f_col = f_col + 1
  236.  
  237.             *-- next try first column, one row down
  238.             CASE f_element(f_row+1,1) <= f_lastopt
  239.                f_row = f_row + 1
  240.                f_col = 1
  241.  
  242.             *-- otherwise, go to beginning (may want to disable this)
  243.             OTHERWISE
  244.                f_row = p_top
  245.                f_col = 1
  246.  
  247.          ENDCASE
  248.  
  249.  
  250.       CASE lkey = 19 .OR. lkey = 8
  251.          *-- Left Arrow or Back Space
  252.  
  253.          DO CASE
  254.             *-- first try same row, one column to the left
  255.             CASE f_element(f_row,f_col-1) <= f_lastopt
  256.                f_col = f_col - 1
  257.  
  258.             *-- next try last column, one row up
  259.             CASE f_element(f_row-1,f_lastcol) <= f_lastopt
  260.                f_row = f_row - 1
  261.                f_col = f_lastcol
  262.  
  263.             *-- then must be on first option, so try to go to end
  264.             CASE f_element(f_lastrow,f_lastcol) <= f_lastopt
  265.                f_row = f_lastrow
  266.                f_col = f_lastcol
  267.  
  268.             *-- if that didn't work, row didn't fill to end so go up 1
  269.             OTHERWISE
  270.                f_row = f_lastrow - 1
  271.                f_col = f_lastcol
  272.  
  273.          ENDCASE
  274.  
  275.       CASE lkey = 3
  276.          *-- Page Down key
  277.          IF f_lastopt < LEN(p_opts)            && see if any more elements exist
  278.             f_firstopt = f_lastopt + 1         && position one beyond last
  279.             DO f_say_opts                      && re-display new options set
  280.          ENDIF
  281.  
  282.  
  283.       CASE lkey = 18
  284.          *-- Page Up key
  285.          IF f_firstopt > 1                     && see if not at top
  286.             *-- if on a second page, then the previous page must
  287.             *-- have been filled, so subtract options per page
  288.             f_firstopt = f_firstopt - ( (p_bottom - p_top + 1) * p_cols )
  289.             DO f_say_opts                      && re-display new options set
  290.          ENDIF
  291.  
  292.  
  293.       CASE lkey = 1
  294.          *-- Home Key
  295.          f_row = p_top
  296.          f_col = 1
  297.  
  298.  
  299.       CASE lkey = 6
  300.          *-- End key
  301.  
  302.          *-- try to go to the end
  303.          IF f_element(f_lastrow,f_lastcol) <= f_lastopt
  304.             f_row = f_lastrow
  305.             f_col = f_lastcol
  306.          ELSE
  307.             *-- if that didn't work, row didn't fill to end so go up 1
  308.             f_row = f_lastrow - 1
  309.             f_col = f_lastcol
  310.          ENDIF
  311.  
  312.    ENDCASE
  313. ENDDO
  314.  
  315. IF f_choice > 0 .AND. f_choice <= LEN(p_opts)
  316.    SETCOLOR(f_selected)
  317.    @ f_row,f_column[f_col] SAY p_opts[f_choice]
  318. ENDIF
  319.  
  320. *-- if messages are on, clear the message line
  321. IF f_mess_on
  322.    @ p_messrow,0
  323. ENDIF
  324.  
  325. *-- restore original color, redraw box
  326. SETCOLOR(f_incolor)
  327. RETURN (f_choice)
  328.  
  329.  
  330.  
  331.  
  332. *****************************************************************************
  333. * Procedure: F_SAY_OPTS
  334. * Notes....: Sub-routine to display the optins in the window
  335. * Assumes..: The memvar <f_firstopt> is the array element number
  336. *            to use in starting the display.
  337. *****************************************************************************
  338. PROCEDURE f_say_opts
  339.  
  340. *-- set up LAST values
  341. f_lastopt = LEN(p_opts)          && default last array element
  342. f_lastrow = p_bottom             && maximun last row is actual last row used
  343.  
  344. *-- starting display controls
  345. STORE p_top TO f_row, f_lastrow
  346. STORE 1     TO f_col, f_lastcol
  347.  
  348. SETCOLOR(f_display)                            && use display color
  349. SCROLL(p_top, p_left, p_bottom, p_right, 0)    && clear window for display
  350.  
  351. FOR f_x = f_firstopt TO LEN(p_opts)            && display starting at first
  352.    IF f_col > p_cols                           && when we get to last column
  353.       f_col = 1                                && loop around
  354.       f_row = f_row + 1                        && and down one row
  355.    ENDIF
  356.    IF f_row > p_bottom                         && if row is below the bottom
  357.       f_lastopt = f_x - 1                      && tag last array element used
  358.       EXIT                                     && and stop listing elements
  359.    ENDIF
  360.    @ f_row,f_column[f_col] SAY p_opts[f_x]     && display this option
  361.    f_lastrow = f_row                           && tag the last row used
  362.    f_lastcol = MAX( f_col, f_lastcol )         && tag farthest column used
  363.    f_col = f_col + 1                           && next column
  364. NEXT f_x
  365.  
  366. *-- start at row,column number 1
  367. f_col = 1
  368. f_row = p_top
  369.  
  370. RETURN
  371.  
  372.  
  373.  
  374.  
  375.  
  376.  
  377. *****************************************************************************
  378. * Function: F_ELEMENT
  379. * Syntax..: F_ELEMENT( f_row, f_col )
  380. * Notes...: Function to return the array element number corresponding
  381. *           to the row,col coordinates specified.
  382. * Assumes.: The memvar <f_firstopt> = the element number of the first
  383. *           option displayed in the window.  This is used as the offset
  384. *           to determine the element number based on the current Page.
  385. *
  386. * Parms...:   row_num = The actual row number
  387. *             col_num = The column array element number
  388. *
  389. *  the array element number will be calculated from the formula:
  390. *  element = ( (relative_row_number - 1) * number_of_columns) +;
  391. *            column_num + ( f_firstopt - 1 )
  392. *  where: relative_row_number = real_row_number - top_of_window + 1
  393. *****************************************************************************
  394. FUNCTION f_element
  395. PARAMETERS p_rownum, p_colnum
  396.  
  397. *-- test if an invalid row,col position given
  398. IF p_rownum < p_top .OR. p_rownum > f_lastrow .OR. p_colnum < 1 .OR. p_colnum > f_lastcol
  399.    *-- return invalid element number to cause test to fail
  400.    RETURN f_lastopt + 1
  401. ENDIF
  402.  
  403. RETURN INT(((p_rownum - p_top) * f_lastcol) + p_colnum + f_firstopt - 1)
  404.